diff --git a/code/extfmts.lisp b/code/extfmts.lisp
index d387eed565018a61adce1c875400db0b18aead11..505a9ba728d824e3185930d3e3f4377d7a6eaff2 100644
--- a/code/extfmts.lisp
+++ b/code/extfmts.lisp
@@ -5,7 +5,7 @@
 ;;; domain.
 ;;; 
 (ext:file-comment
- "$Header: /Volumes/share2/src/cmucl/cvs2git/cvsroot/src/code/extfmts.lisp,v 1.13 2009/08/11 03:30:27 rtoy Exp $")
+ "$Header: /Volumes/share2/src/cmucl/cvs2git/cvsroot/src/code/extfmts.lisp,v 1.14 2009/08/13 13:55:13 rtoy Exp $")
 ;;;
 ;;; **********************************************************************
 ;;;
@@ -543,16 +543,25 @@
     `(let ((,nchar ,char)
 	   (,nstate ,state))
        (when (null ,nstate) (setq ,nstate (setf ,state (cons nil nil))))
-       (if (<= #xD800 (char-code ,nchar) #xDBFF)
+       (if (lisp::surrogatep (char-code ,nchar) :high)
 	   (setf (car ,nstate) ,nchar)
 	   (flet ((,wryte (,ch)
 		    (codepoint-to-octets ,external-format ,ch (cdr ,nstate)
 					 ,output)))
 	     (declare (dynamic-extent #',wryte))
 	     (if (car ,nstate)
-		 (prog1 (,wryte (surrogates-to-codepoint (car ,nstate) ,nchar))
+		 (prog1
+		     ;; Invalid surrogate sequences get replaced with
+		     ;; the replacement character.
+		     (,wryte (if (lisp::surrogatep (char-code ,nchar) :low)
+				 (surrogates-to-codepoint (car ,nstate) ,nchar)
+				 +replacement-character-code+))
 		   (setf (car ,nstate) nil))
-		 (,wryte (char-code ,nchar))))))))
+		 ;; A lone trailing (low) surrogate gets replaced with
+		 ;; the replacement character.
+		 (,wryte (if (lisp::surrogatep (char-code ,nchar) :low)
+			     +replacement-character-code+
+			     (char-code ,nchar)))))))))
 
 (def-ef-macro ef-string-to-octets (extfmt lisp::lisp +ef-max+ +ef-so+)
   `(lambda (string start end buffer &aux (ptr 0) (state nil))