diff --git a/code/pprint.lisp b/code/pprint.lisp
index 288e651b580acd996ef6f13d6fbe4680e585a051..c879f0201f90d98283b034696b01ea53cbe6cc4c 100644
--- a/code/pprint.lisp
+++ b/code/pprint.lisp
@@ -7,7 +7,7 @@
 ;;; Scott Fahlman or slisp-group@cs.cmu.edu.
 ;;;
 (ext:file-comment
-  "$Header: /Volumes/share2/src/cmucl/cvs2git/cvsroot/src/code/pprint.lisp,v 1.8 1992/01/24 04:34:46 wlott Exp $")
+  "$Header: /Volumes/share2/src/cmucl/cvs2git/cvsroot/src/code/pprint.lisp,v 1.9 1992/06/14 07:28:46 wlott Exp $")
 ;;;
 ;;; **********************************************************************
 ;;;
@@ -673,32 +673,31 @@
 
 ;;;; Utilities.
 
-(defun maybe-initiate-pretty-printing (stream function)
-  (if (pretty-stream-p stream)
-      (funcall function stream)
-      (catch 'line-limit-abbreviation-happened
-	(let ((stream (make-pretty-stream stream)))
-	  (funcall function stream)
-	  (force-pretty-output stream)))))
-
-(defmacro with-pretty-stream ((stream-var) &body body)
-  `(maybe-initiate-pretty-printing
-    ,stream-var
-    #'(lambda (,stream-var)
-	,@body)))
+;;; WITH-PRETTY-STREAM -- internal.
+;;;
+(defmacro with-pretty-stream
+	  ((stream-var &optional (stream-expression stream-var)) &body body)
+  (let ((flet-name (gensym "WITH-PRETTY-STREAM-")))
+    `(flet ((,flet-name (,stream-var)
+	      ,@body))
+       (let ((stream ,stream-expression))
+	 (if (pretty-stream-p stream)
+	     (,flet-name stream)
+	     (catch 'line-limit-abbreviation-happened
+	       (let ((stream (make-pretty-stream stream)))
+		 (,flet-name stream)
+		 (force-pretty-output stream)))))
+       nil)))
 
 
 ;;;; User interface to the pretty printer.
 
 (defmacro pprint-logical-block
-	  ((stream-symbol object &key prefix per-line-prefix suffix
-			  allow-atoms (descend t) (check-for-circularity t)
-			  (initiate-pretty-printing t))
+	  ((stream-symbol object &key prefix per-line-prefix suffix)
 	   &body body)
   "Group some output into a logical block.  STREAM-SYMBOL should be either a
    stream, T (for *TERMINAL-IO*), or NIL (for *STANDARD-OUTPUT*).  The printer
-   control variables *PRINT-LEVEL* and *PRINT-CIRCLE* are automatically
-   handled.  See the manual for details."
+   control variable *PRINT-LEVEL* is automatically handled."
   (when (and prefix per-line-prefix)
     (error "Cannot specify both a prefix and a per-line-perfix."))
   (multiple-value-bind
@@ -715,71 +714,55 @@
 		      ((nil) *standard-output*)
 		      ((t) *terminal-io*)
 		      (t ,stream))))))
-    (let* ((object-var (gensym))
-	   (block-name (gensym))
-	   (count-name (gensym))
-	   (pp-pop-name (gensym)))
-      `(%pprint-logical-block
-	,stream-expression ,object ,(or prefix per-line-prefix)
-	,(not (null per-line-prefix)) ,suffix
-	,allow-atoms ,descend ,check-for-circularity ,initiate-pretty-printing
-	#'(lambda (,stream-var ,object-var)
-	    (let ((,count-name 0))
-	      (declare (type index ,count-name) (ignorable ,count-name))
-	      (block ,block-name
-		(flet ((,pp-pop-name ()
-			 (unless (listp ,object-var)
-			   (write-string ". " ,stream-var)
-			   (output-object ,object-var ,stream-var)
-			   (return-from ,block-name nil))
-			 (when (eql ,count-name *print-length*)
-			   (write-string "..." ,stream-var)
-			   (return-from ,block-name nil))
-			 (when (and ,object-var
-				    (plusp ,count-name)
-				    (check-for-circularity ,object-var))
-			   (write-string ". " ,stream-var)
-			   (output-object ,object-var ,stream-var)
-			   (return-from ,block-name nil))
-			 (incf ,count-name)
-			 (pop ,object-var)))
-		  (declare (ignorable #',pp-pop-name))
-		  (macrolet ((pprint-pop ()
-			       '(,pp-pop-name))
-			     (pprint-exit-if-list-exhausted ()
-			       `(when (null ,',object-var)
-				  (return-from ,',block-name nil))))
-		    ,@body)))))))))
-
-(defun %pprint-logical-block (stream object prefix per-line-p suffix
-				     allow-atoms descend check-circularity
-				     initiate-pretty-printing body)
-  (if (or allow-atoms (listp object))
-      (labels ((do-body (stream)
-		 (start-logical-block stream prefix per-line-p suffix)
-		 (funcall body stream (if allow-atoms nil object))
-		 (end-logical-block stream))
-	       (maybe-init (stream)
-		 (cond ((pretty-stream-p stream)
-			(do-body stream))
-		       (initiate-pretty-printing
-			(with-pretty-stream (stream)
-			  (do-body stream)))
-		       (t
-			(write-string prefix stream)
-			(funcall body stream (if allow-atoms nil object))
-			(write-string suffix stream))))
-	       (maybe-circular ()
-		 (if (and object check-circularity)
-		     (with-circularity-detection (object stream)
-		       (maybe-init stream))
-		     (maybe-init stream))))
-	(if descend
-	    (descend-into (nil stream)
-	      (maybe-circular))
-	    (maybe-circular)))
-      (output-object object stream))
-  nil)
+    (let* ((object-var (if object (gensym) nil))
+	   (block-name (gensym "PPRINT-LOGICAL-BLOCK-"))
+	   (count-name (gensym "PPRINT-LOGICAL-BLOCK-LENGTH-"))
+	   (pp-pop-name (gensym "PPRINT-POP-"))
+	   (body
+	    `(descend-into (,stream-var)
+	       (let ((,count-name 0))
+		 (declare (type index ,count-name) (ignorable ,count-name))
+		 (start-logical-block ,stream-var ,(or prefix per-line-prefix)
+				      ,(if per-line-prefix t nil) ,suffix)
+		 (block ,block-name
+		   (flet ((,pp-pop-name ()
+			    ,@(when object
+				`((unless (listp ,object-var)
+				    (write-string ". " ,stream-var)
+				    (output-object ,object-var ,stream-var)
+				    (return-from ,block-name nil))))
+			    (when (eql ,count-name *print-length*)
+			      (write-string "..." ,stream-var)
+			      (return-from ,block-name nil))
+			    ,@(when object
+				`((when (and ,object-var
+					     (plusp ,count-name)
+					     (check-for-circularity
+					      ,object-var))
+				    (write-string ". " ,stream-var)
+				    (output-object ,object-var ,stream-var)
+				    (return-from ,block-name nil))))
+			    (incf ,count-name)
+			    ,@(when object
+				`((pop ,object-var)))))
+		     (declare (ignorable #',pp-pop-name))
+		     (macrolet ((pprint-pop ()
+				  '(,pp-pop-name))
+				(pprint-exit-if-list-exhausted ()
+				  ,(if object
+				       `'(when (null ,object-var)
+					   (return-from ,block-name nil))
+				       `'(return-from ,block-name nil))))
+		       ,@body)))
+		 (end-logical-block ,stream-var)))))
+      (when object
+	(setf body
+	      `(let ((,object-var ,object))
+		 (if (listp ,object-var)
+		     ,body
+		     (output-object ,object-var ,stream-var)))))
+      `(with-pretty-stream (,stream-var ,stream-expression)
+	 ,body))))
 
 (defmacro pprint-exit-if-list-exhausted ()
   "Cause the closest enclosing use of PPRINT-LOGICAL-BLOCK to return
@@ -1116,8 +1099,7 @@
 	 (pprint-multi-dim-array stream array))))
 
 (defun pprint-vector (stream vector)
-  (pprint-logical-block (stream vector :allow-atoms t
-				:prefix "#(" :suffix ")")
+  (pprint-logical-block (stream nil :prefix "#(" :suffix ")")
     (dotimes (i (length vector))
       (pprint-pop)
       (unless (zerop i)
@@ -1126,31 +1108,30 @@
       (output-object (aref vector i) stream))))
 
 (defun pprint-multi-dim-array (stream array)
-  (pprint-logical-block (stream array :descend nil :allow-atoms t)
-    (funcall (formatter "#~DA") stream (array-rank array))
-    (lisp::with-array-data ((data array) (start) (end))
-      (declare (ignore end))
-      (labels ((output-guts (stream index dimensions)
-		 (if (null dimensions)
-		     (output-object (aref data index) stream)
-		     (pprint-logical-block
-			 (stream nil :prefix "(" :suffix ")")
-		       (let ((dim (car dimensions)))
-			 (unless (zerop dim)
-			   (let* ((dims (cdr dimensions))
-				  (index index)
-				  (step (reduce #'* dims))
-				  (count 0))
-			     (loop				
-			       (pprint-pop)
-			       (output-guts stream index dims)
-			       (when (= (incf count) dim)
-				 (return))
-			       (write-char #\space stream)
-			       (pprint-newline (if dims :linear :fill)
-					       stream)
-			       (incf index step)))))))))
-	(output-guts stream start (array-dimensions array))))))
+  (funcall (formatter "#~DA") stream (array-rank array))
+  (lisp::with-array-data ((data array) (start) (end))
+    (declare (ignore end))
+    (labels ((output-guts (stream index dimensions)
+	       (if (null dimensions)
+		   (output-object (aref data index) stream)
+		   (pprint-logical-block
+		       (stream nil :prefix "(" :suffix ")")
+		     (let ((dim (car dimensions)))
+		       (unless (zerop dim)
+			 (let* ((dims (cdr dimensions))
+				(index index)
+				(step (reduce #'* dims))
+				(count 0))
+			   (loop				
+			     (pprint-pop)
+			     (output-guts stream index dims)
+			     (when (= (incf count) dim)
+			       (return))
+			     (write-char #\space stream)
+			     (pprint-newline (if dims :linear :fill)
+					     stream)
+			     (incf index step)))))))))
+      (output-guts stream start (array-dimensions array)))))
 
 (defun pprint-lambda-list (stream lambda-list &rest noise)
   (declare (ignore noise))
@@ -1383,12 +1364,7 @@
 ;;;
 (defun output-pretty-object (object stream)
   (with-pretty-stream (stream)
-    (multiple-value-bind
-	(function found)
-	(pprint-dispatch object)
-      (if found
-	  (funcall function stream object)
-	  (output-ugly-object object stream)))))
+    (funcall (pprint-dispatch object) stream object)))
 
 (defparameter magic-forms
   '((lambda pprint-lambda)