diff --git a/code/backq.lisp b/code/backq.lisp
index 40b58da106eb377a2eee0d79caee68748a3a9020..f3cc1da083e294f6642e640b8a8a3d9b8348c0d5 100644
--- a/code/backq.lisp
+++ b/code/backq.lisp
@@ -7,11 +7,12 @@
 ;;; Scott Fahlman or slisp-group@cs.cmu.edu.
 ;;;
 (ext:file-comment
-  "$Header: /Volumes/share2/src/cmucl/cvs2git/cvsroot/src/code/backq.lisp,v 1.2 1991/02/08 13:30:51 ram Exp $")
+  "$Header: /Volumes/share2/src/cmucl/cvs2git/cvsroot/src/code/backq.lisp,v 1.3 1992/01/16 19:08:55 wlott Exp $")
 ;;;
 ;;; **********************************************************************
 ;;;
 ;;;    BACKQUOTE: Code Spice Lispified by Lee Schumacher.
+;;;   		  (unparsing by Miles Bader)
 ;;;
 (in-package 'lisp)
 
@@ -50,7 +51,6 @@
 (defvar *bq-dot-flag* '(|,.|))
 (defvar *bq-vector-flag* '(|bqv|))
 
-
 ;; This is the actual character macro.
 (defun backquote-macro (stream ignore)
   (declare (ignore ignore))
@@ -79,7 +79,7 @@
 	   (t (unread-char c stream)
 	      (cons *bq-comma-flag* (read stream t nil t))))
      'list)))
-
+
 ;;; This does the expansion from table 2.
 (defun backquotify (code)
   (cond ((atom code)
@@ -159,20 +159,129 @@
 	 (list  'quote thing))
 	((eq flag 'list*)
 	 (cond ((null (cddr thing))
-		(cons 'cons thing))
-	       (t (cons 'list* thing))))
+		(cons 'backq-cons thing))
+	       (t
+		(cons 'backq-list* thing))))
 	((eq flag 'vector)
-	 (list 'apply '#'vector thing))
+	 (list 'backq-vector thing))
 	(t (cons (cdr
 		  (assq flag
-			`((cons . cons) (list . list)
-			  (append . append) (nconc . nconc))))
+			'((cons . backq-cons)
+			  (list . backq-list)
+			  (append . backq-append)
+			  (nconc . backq-nconc))))
 		 thing))))
 
+
+;;;; Magic backq- versions of builtin functions.
+
+;;; Use synonyms for the lisp functions we use, so we can recognize backquoted
+;;; material when pretty-printing
+
+(defun backq-list (&rest args)
+  args)
+(defun backq-list* (&rest args)
+  (apply #'list* args))
+(defun backq-append (&rest args)
+  (apply #'append args))
+(defun backq-nconc (&rest args)
+  (apply #'nconc args))
+(defun backq-cons (x y)
+  (cons x y))
+(defun backq-vector (list)
+  (coerce list 'vector))
+
+
+;;;; Unparsing
+
+(defun backq-unparse-expr (form splicing)
+  (ecase splicing
+    ((nil)
+     `(backq-comma ,form))
+    ((t)
+     `((backq-comma-at ,form)))
+    (:nconc
+     `((backq-comma-dot ,form)))
+    ))
+
+(defun backq-unparse (form &optional splicing)
+  "Given a lisp form containing the magic functions BACKQ-LIST, BACKQ-LIST*,
+  BACKQ-APPEND, etc. produced by the backquote reader macro, will return a
+  corresponding backquote input form.  In this form, `,' `,@' and `,.' are
+  represented by lists whose cars are BACKQ-COMMA, BACKQ-COMMA-AT, and
+  BACKQ-COMMA-DOT respectively, and whose cadrs are the form after the comma.
+  SPLICING indicates whether a comma-escape return should be modified for
+  splicing with other forms: a value of T or :NCONC meaning that an extra
+  level of parentheses should be added."
+  (if (atom form)
+      (backq-unparse-expr form splicing)
+      (case (car form)
+	(backq-list
+	 (mapcar #'backq-unparse (cdr form)))
+	(backq-list*
+	 (do ((tail (cdr form) (cdr tail))
+	      (accum nil))
+	     ((null (cdr tail))
+	      (nconc (nreverse accum)
+		     (backq-unparse (car tail) t)))
+	   (push (backq-unparse (car tail)) accum)))
+	(backq-append
+	 (mapcan #'(lambda (el) (backq-unparse el t))
+		 (cdr form)))
+	(backq-nconc
+	 (mapcan #'(lambda (el) (backq-unparse el :nconc))
+		 (cdr form)))
+	(backq-cons
+	 (cons (backq-unparse (cadr form) nil)
+	       (backq-unparse (caddr form) t)))
+	(backq-vector
+	 (coerce (backq-unparse (cadr form)) 'vector))
+	(quote
+	 (cadr form))
+	(t
+	 (backq-unparse-expr form splicing)))))
 
+(defun pprint-backquote (stream form &rest noise)
+  (declare (ignore noise))
+  (write-char #\` stream)
+  (write (backq-unparse form) :stream stream))
 
+(defun pprint-backq-comma (stream form &rest noise)
+  (declare (ignore noise))
+  (ecase (car form)
+    (backq-comma
+     (write-char #\, stream))
+    (backq-comma-at
+     (princ ",@" stream))
+    (backq-comma-dot
+     (princ ",." stream)))
+  (write (cadr form) :stream stream))
+
+
+;;;; BACKQ-INIT and BACKQ-PP-INIT
 
+;;; BACKQ-INIT -- interface.
+;;;
+;;; This is called by %INITIAL-FUNCTION.
+;;; 
 (defun backq-init ()
   (let ((*readtable* std-lisp-readtable))
     (set-macro-character #\` #'backquote-macro)
     (set-macro-character #\, #'comma-macro)))
+
+;;; BACKQ-PP-INIT -- interface.
+;;;
+;;; This is called by PPRINT-INIT.  This must be seperate from BACKQ-INIT
+;;; because SET-PPRINT-DISPATCH doesn't work until the compiler is loaded.
+;;;
+(defun backq-pp-init ()
+  (set-pprint-dispatch '(cons (eql backq-list)) #'pprint-backquote)
+  (set-pprint-dispatch '(cons (eql backq-list*)) #'pprint-backquote)
+  (set-pprint-dispatch '(cons (eql backq-append)) #'pprint-backquote)
+  (set-pprint-dispatch '(cons (eql backq-nconc)) #'pprint-backquote)
+  (set-pprint-dispatch '(cons (eql backq-cons)) #'pprint-backquote)
+  (set-pprint-dispatch '(cons (eql backq-vector)) #'pprint-backquote)
+  
+  (set-pprint-dispatch '(cons (eql backq-comma)) #'pprint-backq-comma)
+  (set-pprint-dispatch '(cons (eql backq-comma-at)) #'pprint-backq-comma)
+  (set-pprint-dispatch '(cons (eql backq-comma-dot)) #'pprint-backq-comma))