diff --git a/code/defstruct.lisp b/code/defstruct.lisp
index 9b47189f1dd7447cef8085489a4d83c04cad3fa4..0bc314460f386a72ac8aee2a05e7d262b009f238 100644
--- a/code/defstruct.lisp
+++ b/code/defstruct.lisp
@@ -5,7 +5,7 @@
 ;;; Carnegie Mellon University, and has been placed in the public domain.
 ;;;
 (ext:file-comment
-  "$Header: /Volumes/share2/src/cmucl/cvs2git/cvsroot/src/code/defstruct.lisp,v 1.72 2001/03/04 20:12:32 pw Exp $")
+  "$Header: /Volumes/share2/src/cmucl/cvs2git/cvsroot/src/code/defstruct.lisp,v 1.73 2001/03/15 18:01:36 pw Exp $")
 ;;;
 ;;; **********************************************************************
 ;;;
@@ -30,8 +30,13 @@
 	  defstruct-description dd-name dd-default-constructor dd-copier
 	  dd-predicate dd-slots dd-length dd-type dd-raw-index dd-raw-length
 	  defstruct-slot-description dsd-name dsd-%name dsd-accessor dsd-type
-	  dsd-index dsd-raw-type dsd-read-only undefine-structure))
+	  dsd-index dsd-raw-type dsd-read-only undefine-structure
+	  *ansi-defstruct-options-p*))
 
+
+(defparameter *ANSI-defstruct-options-p* nil
+  "Controls compiling DEFSTRUCT :print-function and :print-method
+   options according to ANSI spec. MUST be NIL to compile CMUCL & PCL")
 
 ;;;; Structure frobbing primitives.
 
@@ -323,6 +328,27 @@
   (declare (ignore depth))
   (format stream "#<Defstruct-Slot-Description for ~S>" (dsd-name structure)))
 
+
+(defun dd-maybe-make-print-method (defstruct)
+  ;; Maybe generate CLOS DEFMETHOD forms for :print-function/:print-object.
+  (let ((print-function-value (dd-print-function defstruct)))
+    (when (consp print-function-value)
+      (let ((kind (car print-function-value))
+	    (function (cdr print-function-value)))
+	(unless (eq kind 'lambda)
+	  (setf (dd-print-function defstruct) nil)
+	  (let* ((name (dd-name defstruct))
+		 (function (if (symbolp function) `',function `#',function))
+		 (mcall `(funcall ,function o s))
+		 (fcall `(funcall ,function o s *current-level*)))
+	    ;; We can only generate this code if CLOS is loaded. Maybe should
+	    ;; signal an error instead of quietly ignoring the defmethod?
+	    `((when (fboundp 'print-object)
+		(defmethod print-object ((o ,name) s)
+		  ,(ecase kind
+		     (:print-object mcall)
+		     (:print-function fcall)))))))))))
+
 
 ;;; The legendary macro itself.
 
@@ -331,6 +357,36 @@
 ;;; Return a list of forms to install print and make-load-form funs, mentioning
 ;;; them in the expansion so that they can be compiled.
 ;;;
+
+(defun define-class-methods (defstruct)
+  (let* ((name (dd-name defstruct))
+	 (pom (dd-maybe-make-print-method defstruct)))
+    `(,@(let ((pf (dd-print-function defstruct)))
+	  (when pf
+	    `((setf (basic-structure-class-print-function (find-class ',name))
+		    ,(if (symbolp pf)
+			 `',pf
+			 `#',pf)))))
+      ,@(let ((mlff (dd-make-load-form-fun defstruct)))
+	  (when mlff
+	    `((setf (structure-class-make-load-form-fun (find-class ',name))
+		    ,(if (symbolp mlff)
+			 `',mlff
+			 `#',mlff)))))
+      ,@(let ((pure (dd-pure defstruct)))
+	  (cond ((eq pure 't)
+		 `((setf (layout-pure (class-layout (find-class ',name)))
+		    t)))
+		((eq pure :substructure)
+		 `((setf (layout-pure (class-layout (find-class ',name)))
+		    0)))))
+      ,@(let ((def-con (dd-default-constructor defstruct)))
+	  (when (and def-con (not (dd-alternate-metaclass defstruct)))
+	    `((setf (structure-class-constructor (find-class ',name))
+		    #',def-con))))
+      ,@pom)))
+
+#+ORIGINAL
 (defun define-class-methods (defstruct)
   (let ((name (dd-name defstruct)))
     `(,@(let ((pf (dd-print-function defstruct)))
@@ -425,6 +481,69 @@
 ;;;
 ;;;    Parse a single defstruct option and store the results in Defstruct.
 ;;;
+(defun parse-1-option (option defstruct)
+  (let ((args (rest option))
+	(name (dd-name defstruct)))
+    (case (first option)
+      (:conc-name
+       (destructuring-bind (conc-name) args
+	 (setf (dd-conc-name defstruct)
+	       (if (symbolp conc-name)
+		   conc-name
+		   (make-symbol (string conc-name))))))
+      (:constructor
+       (destructuring-bind (&optional (cname (concat-pnames 'make- name))
+				      &rest stuff)
+			   args
+	 (push (cons cname stuff) (dd-constructors defstruct))))
+      (:copier
+       (destructuring-bind (&optional (copier (concat-pnames 'copy- name)))
+			   args
+	 (setf (dd-copier defstruct) copier)))
+      (:predicate
+       (destructuring-bind (&optional (pred (concat-pnames name '-p)))
+			   args
+	 (setf (dd-predicate defstruct) pred)))
+      (:include
+       (when (dd-include defstruct)
+	 (error "Can't have more than one :INCLUDE option."))
+       (setf (dd-include defstruct) args))
+      (:alternate-metaclass
+       (setf (dd-alternate-metaclass defstruct) args))
+      ((:print-function :print-object)
+       (destructuring-bind (&optional (fun 'default-structure-print)) args
+	 (setf (dd-print-function defstruct)
+	       (if *ANSI-defstruct-options-p*
+		   (cons (first option) fun)
+		   fun))))
+      (:type
+       (destructuring-bind (type) args
+	 (cond ((eq type 'funcallable-structure)
+		(setf (dd-type defstruct) type))
+	       ((member type '(list vector))
+		(setf (dd-element-type defstruct) 't)
+		(setf (dd-type defstruct) type))
+	       ((and (consp type) (eq (first type) 'vector))
+		(destructuring-bind (vector vtype) type
+		  (declare (ignore vector))
+		  (setf (dd-element-type defstruct) vtype)
+		  (setf (dd-type defstruct) 'vector)))
+	       (t
+		(error "~S is a bad :TYPE for Defstruct." type)))))
+      (:named
+       (error "The Defstruct option :NAMED takes no arguments."))
+      (:initial-offset
+       (destructuring-bind (offset) args
+	 (setf (dd-offset defstruct) offset)))
+      (:make-load-form-fun
+       (destructuring-bind (fun) args
+	 (setf (dd-make-load-form-fun defstruct) fun)))
+      (:pure
+       (destructuring-bind (fun) args
+	 (setf (dd-pure defstruct) fun)))
+      (t (error "Unknown DEFSTRUCT option~%  ~S" option)))))
+
+#+ORIGINAL
 (defun parse-1-option (option defstruct)
   (let ((args (rest option))
 	(name (dd-name defstruct)))
diff --git a/code/exports.lisp b/code/exports.lisp
index f9b5bfa81eb19ab2a60798c482f8827d8a8ff50c..fa173132e3cac14171dd0e542de480cec5af6929 100644
--- a/code/exports.lisp
+++ b/code/exports.lisp
@@ -5,7 +5,7 @@
 ;;; Carnegie Mellon University, and has been placed in the public domain.
 ;;;
 (ext:file-comment
-  "$Header: /Volumes/share2/src/cmucl/cvs2git/cvsroot/src/code/exports.lisp,v 1.181 2001/03/13 16:39:07 pw Exp $")
+  "$Header: /Volumes/share2/src/cmucl/cvs2git/cvsroot/src/code/exports.lisp,v 1.182 2001/03/15 18:01:36 pw Exp $")
 ;;;
 ;;; **********************************************************************
 ;;;
@@ -875,10 +875,12 @@
 
 (intern "CHAR" "LISP")
 (defpackage "EXTENSIONS"
-	    (:nicknames "EXTENSIONS")
-            (:import-from "LISP" "GET-SETF-METHOD")
-            (:export "*AFTER-GC-HOOKS*" "*AFTER-SAVE-INITIALIZATIONS*"
-             "*ALL-MODIFIER-NAMES*" "*AUTOLOAD-TRANSLATIONS*"
+  (:nicknames "EXTENSIONS")
+  (:import-from "LISP" "GET-SETF-METHOD")
+  (:import-from "KERNEL" "*ANSI-DEFSTRUCT-OPTIONS-P*")
+  (:export   "*AFTER-GC-HOOKS*" "*AFTER-SAVE-INITIALIZATIONS*"
+	     "*ALL-MODIFIER-NAMES*" "*ANSI-DEFSTRUCT-OPTIONS-P*"
+	     "*AUTOLOAD-TRANSLATIONS*"
 	     "*BACKUP-EXTENSION*" "*BEFORE-GC-HOOKS*"
              "*BEFORE-SAVE-INITIALIZATIONS*" "*BLOCK-COMPILE-DEFAULT*"
              "*BYTES-CONSED-BETWEEN-GCS*" "*CHAR" "*CLX-FDS-TO-DISPLAYS*"
@@ -1438,7 +1440,8 @@
 (defpackage "KERNEL"
   (:import-from "LISP" "BOOLEAN")
   (:import-from "C-CALL" "VOID")
-  (:export "%ACOS" "%ACOSH" "%ARRAY-AVAILABLE-ELEMENTS"
+  (:export "*ANSI-DEFSTRUCT-OPTIONS-P*"
+	   "%ACOS" "%ACOSH" "%ARRAY-AVAILABLE-ELEMENTS"
 	   "%ARRAY-DATA-VECTOR" "%ARRAY-DIMENSION" "%ARRAY-DISPLACED-P"
 	   "%ARRAY-DISPLACEMENT" "%ARRAY-FILL-POINTER"
 	   "%ARRAY-FILL-POINTER-P" "%ASIN" "%ASINH" "%ATAN" "%ATAN2" "%ATANH"
diff --git a/code/print.lisp b/code/print.lisp
index 970dbd24eb8fe1d1dde75660c65347e1876fae9a..82737cfd7f49d0344892afd591e057daea1b7718 100644
--- a/code/print.lisp
+++ b/code/print.lisp
@@ -5,7 +5,7 @@
 ;;; Carnegie Mellon University, and has been placed in the public domain.
 ;;;
 (ext:file-comment
-  "$Header: /Volumes/share2/src/cmucl/cvs2git/cvsroot/src/code/print.lisp,v 1.79 2001/01/01 11:41:17 dtc Exp $")
+  "$Header: /Volumes/share2/src/cmucl/cvs2git/cvsroot/src/code/print.lisp,v 1.80 2001/03/15 18:01:37 pw Exp $")
 ;;;
 ;;; **********************************************************************
 ;;;
@@ -1127,6 +1127,39 @@
 ;;; Instance Printing.  If it's a structure, call the structure printer.
 ;;; Otherwise, call PCL if it's loaded.  If not, print unreadably.
 
+(defun output-instance (instance stream)
+  (let ((layout (typecase instance
+		  (instance (%instance-ref instance 0))
+		  (funcallable-instance
+		   (%funcallable-instance-layout instance)))))
+
+    (if (typep layout 'layout)
+	(let ((class (layout-class layout)))
+	  (cond
+	   ((typep class 'slot-class) ; has slot print-function
+	    (if (layout-invalid layout)
+		(print-unreadable-object
+		    (instance stream :identity t :type t)
+		  (write-string "Obsolete Instance" stream))
+		(cond (;; non-CLOS :print-function option
+		       (slot-class-print-function class)
+		       (funcall (slot-class-print-function class)
+				instance stream *current-level*))
+		      ;; When CLOS loaded, use PRINT-OBJECT.
+		      ((fboundp 'print-object)
+		       (print-object instance stream))
+		      (t
+		       (default-structure-print
+			   instance stream *current-level*)))))
+	   ((fboundp 'print-object)
+	    (print-object instance stream))
+	   (t
+	    (print-unreadable-object (instance stream :identity t)
+	      (write-string "Unprintable Instance" stream)))))
+	(print-unreadable-object (instance stream :identity t)
+	  (write-string "Unprintable Instance" stream)))))
+
+#+ORIGINAL
 (defun output-instance (instance stream)
   (let ((layout (typecase instance
 		  (instance (%instance-ref instance 0))
diff --git a/tools/pclcom.lisp b/tools/pclcom.lisp
index 7c4ac881fe6f3cae64ec3fafd7d91c0ba66cb3c8..a244e84940d07e17a229c24b8390484275f28ac4 100644
--- a/tools/pclcom.lisp
+++ b/tools/pclcom.lisp
@@ -3,7 +3,7 @@
 ;;; **********************************************************************
 ;;;
 (ext:file-comment
-  "$Header: /Volumes/share2/src/cmucl/cvs2git/cvsroot/src/tools/pclcom.lisp,v 1.21 2000/06/29 07:52:06 dtc Exp $")
+  "$Header: /Volumes/share2/src/cmucl/cvs2git/cvsroot/src/tools/pclcom.lisp,v 1.22 2001/03/15 18:01:39 pw Exp $")
 ;;;
 ;;; **********************************************************************
 ;;;
@@ -69,6 +69,9 @@
 (when (find-package "CLOS-MOP")
   (rename-package "CLOS-MOP" "OLD-CLOS-MOP"))
 
+;;; Inhibit ANSI :print-function and :print-object defstruct options.
+(setq kernel::*ansi-defstruct-options-p* nil)
+
 (setf c:*suppress-values-declaration* t)
 (pushnew :setf *features*)
 
diff --git a/tools/setup.lisp b/tools/setup.lisp
index 85e030c57af4f228d7d1f83a951932687ef528b8..ee128a7b30292fe94f36a92ec2b2bf67ea98e46a 100644
--- a/tools/setup.lisp
+++ b/tools/setup.lisp
@@ -3,15 +3,21 @@
 ;;; **********************************************************************
 ;;;
 (ext:file-comment
-  "$Header: /Volumes/share2/src/cmucl/cvs2git/cvsroot/src/tools/setup.lisp,v 1.30 2001/02/11 14:22:07 dtc Exp $")
+  "$Header: /Volumes/share2/src/cmucl/cvs2git/cvsroot/src/tools/setup.lisp,v 1.31 2001/03/15 18:01:39 pw Exp $")
 ;;;
 ;;; **********************************************************************
 ;;;
 ;;;    Set up package environment and search lists for compiler.  Also some
 ;;; compilation utilities.
 ;;;
+
+;;; Ensure pre-ANSI defstruct processing occurs during system builds.
+(in-package "KERNEL")
+(defparameter *ansi-defstruct-options-p* nil)
+
 (in-package "USER")
 
+
 
 ;;; DUMP-PACKAGE-STATE  --  Public
 ;;;
diff --git a/tools/worldload.lisp b/tools/worldload.lisp
index 2d70cb3c6bf403f082dc385c6f634145bd771727..35f03a1d6d04a783d82328e32fd1a17dabd2ad10 100644
--- a/tools/worldload.lisp
+++ b/tools/worldload.lisp
@@ -6,7 +6,7 @@
 ;;; If you want to use this code or any part of CMU Common Lisp, please contact
 ;;; Scott Fahlman or slisp-group@cs.cmu.edu.
 ;;;
-;;; $Header: /Volumes/share2/src/cmucl/cvs2git/cvsroot/src/tools/worldload.lisp,v 1.90 2001/03/13 14:14:50 pw Exp $
+;;; $Header: /Volumes/share2/src/cmucl/cvs2git/cvsroot/src/tools/worldload.lisp,v 1.91 2001/03/15 18:01:40 pw Exp $
 ;;;
 ;;; **********************************************************************
 ;;;
@@ -216,6 +216,9 @@
   ;;; Reset the counter of the number of native code fixups.
   #+x86 (setf x86::*num-fixups* 0)
 
+  ;; Maybe enable ANSI defstruct :print-function/:print-object processing
+  #-NO-PCL
+  (setq ext:*ansi-defstruct-options-p* t)
   ;;
   ;; Save the lisp.  If RUNTIME, there is nothing new to purify, so don't.
   (save-lisp "lisp.core"