diff --git a/src/code/error.lisp b/src/code/error.lisp
index 2678d221f4065c9807c553475458977513d3e068..5b72100aa4f3d063dd1d4bf3570f0d6f4caac73b 100644
--- a/src/code/error.lisp
+++ b/src/code/error.lisp
@@ -1203,6 +1203,27 @@
   `(handler-case (progn ,@forms)
      (error (condition) (values nil condition))))
 
+
+;;;; Reader
+
+(define-condition standard-readtable-modified-error (reference-condition error)
+  ((operation :initarg :operation
+	      :reader standard-readtable-modified-operation))
+  (:report (lambda (condition stream)
+	     (format stream "~S would modify the standard readtable."
+		     (standard-readtable-modified-operation condition))))
+  (:default-initargs :references `((:ansi-cl :section (2 1 1 2))
+				   (:ansi-cl :glossary "standard readtable"))))
+
+;;;; Pprint dispatch
+
+(define-condition standard-pprint-dispatch-table-modified-error (reference-condition error)
+  ((operation :initarg :operation
+	      :reader standard-pprint-dispatch-table-modified-operation))
+  (:report (lambda (condition stream)
+	     (format stream "~S would modify the standard pprint dispatch table."
+		     (standard-pprint-dispatch-table-modified-operation condition))))
+  (:default-initargs :references `((:ansi-cl :glossary "standard pprint dispatch table"))))
 
 
 ;;;; Restart definitions.
@@ -1249,3 +1270,4 @@
 (define-nil-returning-restart use-value (value)
   "Transfer control and value to a restart named use-value, returning nil if
    none exists.")
+
diff --git a/src/code/exports.lisp b/src/code/exports.lisp
index 3e9631b5a955502b00cb0b114fc360159ad3c0d3..2c3e0ff555b818e38690732c8faf5e84a1e805c7 100644
--- a/src/code/exports.lisp
+++ b/src/code/exports.lisp
@@ -2321,7 +2321,9 @@
 
 	   "%COMPLEX-SINGLE-FLOAT"
 	   "%COMPLEX-DOUBLE-FLOAT"
-	   "%COMPLEX-DOUBLE-DOUBLE-FLOAT")
+	   "%COMPLEX-DOUBLE-DOUBLE-FLOAT"
+	   "STANDARD-READTABLE-MODIFIED-ERROR"
+	   "STANDARD-PPRINT-DISPATCH-TABLE-MODIFIED-ERROR")
   #+heap-overflow-check
   (:export "DYNAMIC-SPACE-OVERFLOW-WARNING-HIT"
 	   "DYNAMIC-SPACE-OVERFLOW-ERROR-HIT"
diff --git a/src/code/pprint.lisp b/src/code/pprint.lisp
index d1f570f650d6c04f3dd2039312d8d7f727461c0a..15eafc00b5c3277b270c74128aba89c7bd4cf6d3 100644
--- a/src/code/pprint.lisp
+++ b/src/code/pprint.lisp
@@ -1223,11 +1223,17 @@ When annotations are present, invoke them at the right positions."
 		    (output-ugly-object object stream))
 		nil))))
 
+(defun assert-not-standard-pprint-dispatch-table (pprint-dispatch operation)
+  (when (eq pprint-dispatch *initial-pprint-dispatch*)
+    (cerror "Modify it anyway." 'standard-pprint-dispatch-table-modified-error
+	    :operation operation)))
+
 (defun set-pprint-dispatch (type function &optional
 			    (priority 0) (table *print-pprint-dispatch*))
   (declare (type (or null symbol function) function)
 	   (type real priority)
 	   (type pprint-dispatch-table table))
+  (assert-not-standard-pprint-dispatch-table table 'set-pprint-dispatch)
   (if function
       (if (cons-type-specifier-p type)
 	  (setf (gethash (second (second type))
@@ -1952,18 +1958,25 @@ When annotations are present, invoke them at the right positions."
   (setf *initial-pprint-dispatch* (make-pprint-dispatch-table))
   (let ((*print-pprint-dispatch* *initial-pprint-dispatch*)
 	(*building-initial-table* t))
-    ;; Printers for regular types.
-    (set-pprint-dispatch 'array #'pprint-array)
-    (set-pprint-dispatch '(cons (and symbol (satisfies fboundp)))
-			 #'pprint-function-call -1)
-    (set-pprint-dispatch 'cons #'pprint-fill -2)
-    ;; Cons cells with interesting things for the car.
-    (dolist (magic-form *magic-forms*)
-      (set-pprint-dispatch `(cons (eql ,(first magic-form)))
-			   (symbol-function (second magic-form))))
-    ;; Other pretty-print init forms.
-    (lisp::backq-pp-init)
-    (loop-pp-init))
+    (handler-bind
+	((standard-pprint-dispatch-table-modified-error
+	  (lambda (c)
+	    (declare (ignore c))
+	    ;; Of course, we want to be able to modify the standard
+	    ;; pprint dispatch table here!
+	    (invoke-restart 'kernel::continue))))
+      ;; Printers for regular types.
+      (set-pprint-dispatch 'array #'pprint-array)
+      (set-pprint-dispatch '(cons (and symbol (satisfies fboundp)))
+			   #'pprint-function-call -1)
+      (set-pprint-dispatch 'cons #'pprint-fill -2)
+      ;; Cons cells with interesting things for the car.
+      (dolist (magic-form *magic-forms*)
+	(set-pprint-dispatch `(cons (eql ,(first magic-form)))
+			     (symbol-function (second magic-form))))
+      ;; Other pretty-print init forms.
+      (lisp::backq-pp-init)
+      (loop-pp-init)))
 
   (setf *print-pprint-dispatch* (copy-pprint-dispatch nil))
   (setf *pretty-printer* #'output-pretty-object)
diff --git a/src/code/print.lisp b/src/code/print.lisp
index 3f162d735e3dcf61f5c0c77e104451b8ab05bc04..aae2e0b564927ba1c7354a32959f4b2e3bf865d3 100644
--- a/src/code/print.lisp
+++ b/src/code/print.lisp
@@ -115,7 +115,7 @@
 	(*print-level* nil)
 	(*print-lines* nil)
 	(*print-miser-width* nil)
-	(*print-pprint-dispatch* (copy-pprint-dispatch nil))
+	(*print-pprint-dispatch* pp::*initial-pprint-dispatch*)
 	(*print-pretty* nil)
 	(*print-radix* nil)
 	(*print-readably* t)
diff --git a/src/code/reader.lisp b/src/code/reader.lisp
index de666d122c680075a062f04d3a90871e0ad41bb7..3b4d06bec4662d7e683bd8caca1a5785c2f00705 100644
--- a/src/code/reader.lisp
+++ b/src/code/reader.lisp
@@ -461,8 +461,14 @@
 
 ;;;; Readtable operations.
 
+(defun assert-not-standard-readtable (readtable operation)
+  (when (eq readtable std-lisp-readtable)
+    (cerror "Modify it anyway." 'kernel:standard-readtable-modified-error
+	    :operation operation)))
+
 (defun copy-readtable (&optional (from-readtable *readtable*) to-readtable)
   "A copy is made of from-readtable and place into to-readtable."
+  (assert-not-standard-readtable to-readtable 'copy-readtable)
   (let ((from-readtable (or from-readtable std-lisp-readtable))
 	(to-readtable (or to-readtable (make-readtable))))
     (flet ((copy-hash-table (to from)
@@ -495,6 +501,7 @@
   "Causes the syntax of to-char to be the same as from-char in the 
   optional readtable (defaults to the current readtable).  The
   from-table defaults the standard lisp readtable by being nil."
+  (assert-not-standard-readtable to-readtable 'set-syntax-from-char)
   (let ((from-readtable (or from-readtable std-lisp-readtable)))
     ;;copy from-char entries to to-char entries, but make sure that if
     ;;from char is a constituent you don't copy non-movable secondary
@@ -538,10 +545,12 @@
    make the macro character non-terminating.  The optional readtable
    argument defaults to the current readtable.  Set-macro-character
    returns T."
-  (if non-terminatingp
-      (set-cat-entry char (get-secondary-attribute char) rt)
-      (set-cat-entry char #.terminating-macro rt))
-  (set-cmt-entry char function rt)
+  (let ((designated-readtable (or rt std-lisp-readtable)))
+    (assert-not-standard-readtable designated-readtable 'set-macro-character)
+    (if non-terminatingp
+	(set-cat-entry char (get-secondary-attribute char) designated-readtable)
+	(set-cat-entry char #.terminating-macro designated-readtable))
+    (set-cmt-entry char function designated-readtable))
   T)
 
 (defun get-macro-character (char &optional (rt *readtable*))
@@ -595,46 +604,54 @@
   (setq std-lisp-readtable (make-readtable))
   ;;all characters default to "constituent" in make-readtable
   ;;*** un-constituent-ize some of these ***
-  (let ((*readtable* std-lisp-readtable))
-    (set-cat-entry #\tab #.whitespace)
-    (set-cat-entry #\linefeed #.whitespace)  
-    (set-cat-entry #\space #.whitespace)
-    (set-cat-entry #\page #.whitespace)
-    (set-cat-entry #\return #.whitespace)
-    (set-cat-entry #\\ #.escape)
-    (set-cat-entry #\| #.multiple-escape)
-    (set-cmt-entry #\\ #'read-token)
-    (set-cmt-entry #\: #'read-token)
-    (set-cmt-entry #\| #'read-token)
-    ;;macro definitions
-    (set-macro-character #\" #'read-string)
-    ;;* # macro
-    (set-macro-character #\' #'read-quote)
-    (set-macro-character #\( #'read-list)
-    (set-macro-character #\) #'read-right-paren)
-    (set-macro-character #\; #'read-comment)
-    ;;* backquote
-    ;;all constituents
-    (do ((ichar 0 (1+ ichar))
-	 (len #+unicode-bootstrap #o200
-	      #-unicode-bootstrap char-code-limit))
-	((= ichar len))
-      (let ((char (code-char ichar)))
-	#-unicode
-	(when (constituentp char std-lisp-readtable)
-	  (set-cat-entry char (get-secondary-attribute char))
-	  (set-cmt-entry char #'read-token))
-	#+unicode
-	(cond ((constituentp char std-lisp-readtable)
-	       (set-cat-entry char (get-secondary-attribute char))
-	       (when (< ichar attribute-table-limit)
-		 ;; The hashtable default in get-cmt-entry returns
-		 ;; #'read-token, so don't need to set it here.
-		 (set-cmt-entry char #'read-token)))
-	      ((>= ichar attribute-table-limit)
-	       ;; A non-constituent character that would be stored in
-	       ;; the hash table gets #'undefined-macro-char.
-	       (set-cmt-entry char #'undefined-macro-char)))))))
+  (handler-bind
+      ((standard-readtable-modified-error
+	(lambda (c)
+	  (declare (ignore c))
+	  ;; Of course, we want to be able to modify the standard
+	  ;; readtable here!
+	  (invoke-restart 'kernel::continue))))
+    (let ((*readtable* std-lisp-readtable)
+	  (*assert-not-standard-readtable* nil))
+      (set-cat-entry #\tab #.whitespace)
+      (set-cat-entry #\linefeed #.whitespace)  
+      (set-cat-entry #\space #.whitespace)
+      (set-cat-entry #\page #.whitespace)
+      (set-cat-entry #\return #.whitespace)
+      (set-cat-entry #\\ #.escape)
+      (set-cat-entry #\| #.multiple-escape)
+      (set-cmt-entry #\\ #'read-token)
+      (set-cmt-entry #\: #'read-token)
+      (set-cmt-entry #\| #'read-token)
+      ;;macro definitions
+      (set-macro-character #\" #'read-string)
+      ;;* # macro
+      (set-macro-character #\' #'read-quote)
+      (set-macro-character #\( #'read-list)
+      (set-macro-character #\) #'read-right-paren)
+      (set-macro-character #\; #'read-comment)
+      ;;* backquote
+      ;;all constituents
+      (do ((ichar 0 (1+ ichar))
+	   (len #+unicode-bootstrap #o200
+		#-unicode-bootstrap char-code-limit))
+	  ((= ichar len))
+	(let ((char (code-char ichar)))
+	  #-unicode
+	  (when (constituentp char std-lisp-readtable)
+	    (set-cat-entry char (get-secondary-attribute char))
+	    (set-cmt-entry char #'read-token))
+	  #+unicode
+	  (cond ((constituentp char std-lisp-readtable)
+		 (set-cat-entry char (get-secondary-attribute char))
+		 (when (< ichar attribute-table-limit)
+		   ;; The hashtable default in get-cmt-entry returns
+		   ;; #'read-token, so don't need to set it here.
+		   (set-cmt-entry char #'read-token)))
+		((>= ichar attribute-table-limit)
+		 ;; A non-constituent character that would be stored in
+		 ;; the hash table gets #'undefined-macro-char.
+		 (set-cmt-entry char #'undefined-macro-char))))))))