Index: /trunk/source/lib/defstruct-lds.lisp
===================================================================
--- /trunk/source/lib/defstruct-lds.lisp	(revision 14500)
+++ /trunk/source/lib/defstruct-lds.lisp	(revision 14501)
@@ -70,5 +70,5 @@
   ;There's too much state to keep around here to break it up into little
   ;functions, so what the hell, let's do it all inline...
-  (prog (struct-name type conc-name constructor copier predicate include
+  (prog (struct-name type conc-name constructors copier predicate include
          print-function print-object  named initial-offset boa-constructors print-p
          documentation (slot-list ()) (offset 0) superclasses sd
@@ -79,5 +79,5 @@
       (setq struct-name (pop options)))
     (unless (symbolp struct-name) (signal-program-error $XNotSym struct-name))
-    (let (name args constructor-p predicate-p)
+    (let (name args no-constructors-p predicate-p)
       (while options
         (if (atom (car options))
@@ -92,7 +92,10 @@
            (when (cddr args) (go bad-options))
            (cond ((cdr args) (push args boa-constructors))
-                 (t (when constructor (go dup-options))
-                    (unless (symbolp (%car args)) (go bad-options))
-                    (setq constructor-p t constructor args))))
+		 ((null args)
+		  (push (concat-pnames "MAKE-" struct-name) constructors))
+		 ((eq (%car args) nil)
+		  (setq no-constructors-p t))
+                 (t (unless (symbolp (%car args)) (go bad-options))
+		    (push (%car args) constructors))))
           (:copier
            (when copier (go dup-options))
@@ -158,8 +161,11 @@
             (if (null conc-name) (%str-cat (symbol-name struct-name) "-")
                 (if (%car conc-name) (string (%car conc-name)))))
-      (unless (and boa-constructors (not constructor-p))
-        (setq constructor
-              (if (null constructor)
-                (concat-pnames "MAKE-" struct-name) (%car constructor))))
+      (when (and no-constructors-p
+		 (or constructors boa-constructors))
+	(error "~s combined with other ~s options"
+	       '(:constructor nil) :constructor))
+      (unless no-constructors-p
+	(unless (or boa-constructors constructors)
+	  (push (concat-pnames "MAKE-" struct-name) constructors)))
       (setq copier
             (if (null copier) (concat-pnames "COPY-" struct-name) (%car copier))))
@@ -241,5 +247,5 @@
                 refnames)))
       (setq refnames (nreverse refnames)))
-    (setq sd (vector type slot-list superclasses offset constructor () refnames))
+    (setq sd (vector type slot-list superclasses offset (car constructors) () refnames))
     (return
      `(progn
@@ -263,5 +269,5 @@
         ,.(%defstruct-compile sd refnames env)
         ,.(defstruct-boa-constructors sd boa-constructors env)
-        ,.(if constructor (list (defstruct-constructor sd constructor env)))
+	,.(defstruct-constructors sd constructors env)
        ;; Wait until slot accessors are defined, to avoid
        ;; undefined function warnings in the print function/method.
@@ -301,4 +307,8 @@
     `',(mapcar (lambda (name) (find-class-cell name t)) (cadr class-names))
     class-names))
+
+(defun defstruct-constructors (sd constructors env &aux (list ()))
+  (dolist (c constructors list)
+    (push (defstruct-constructor sd c env) list)))
 
 (defun defstruct-constructor (sd constructor env &aux (offset 0)