diff --git a/collects/mred/mred.ss b/collects/mred/mred.ss
index 448ca8af8b..28b1fa121b 100644
--- a/collects/mred/mred.ss
+++ b/collects/mred/mred.ss
@@ -114,7 +114,6 @@
 	     font%
 	     font-list%
 	     font-name-directory<%>
-	     get-face-list
 	     get-resource
 	     get-the-editor-data-class-list
 	     get-the-snip-class-list
@@ -233,6 +232,7 @@
 	   message+check-box
 	   message-box/custom
 	   message+check-box/custom
+           get-face-list
 	   get-file
 	   get-file-list
 	   put-file
diff --git a/collects/mred/private/fontdialog.ss b/collects/mred/private/fontdialog.ss
index 94ba1fa5ea..15d46aa292 100644
--- a/collects/mred/private/fontdialog.ss
+++ b/collects/mred/private/fontdialog.ss
@@ -39,28 +39,7 @@
 						 (let ([s (send (send edit get-style-list) find-named-style "Standard")])
 						   (send s set-delta (font->delta f))))))]
 	       [p (make-object horizontal-pane% f)]
-	       [face (make-object list-box% #f
-				  (let ([l (wx:get-face-list)]
-					[ugly? (lambda (a)
-						 (and (positive? (string-length a))
-						      (not (or (char-alphabetic? (string-ref a 0))
-							       (char-numeric? (string-ref a 0))
-							       (char=? #\- (string-ref a 0))))))])
-				    ;; Sort space-starting first (for Xft), and
-				    ;;  otherwise push names that start with an
-				    ;;  ASCII non-letter/digit/hyphen to the end
-				    (sort l (lambda (a b)
-                                              (let ([a-sp? (char=? #\space (string-ref a 0))]
-                                                    [b-sp? (char=? #\space (string-ref b 0))]
-                                                    [a-ugly? (ugly? a)]
-                                                    [b-ugly? (ugly? b)])
-                                                (cond [(eq? a-sp? b-sp?)
-                                                       (cond
-                                                        [(eq? a-ugly? b-ugly?)
-                                                         (string-locale-ci<? a b)]
-                                                        [else b-ugly?])]
-                                                      [else a-sp?])))))
-				  p refresh-sample)]
+	       [face (make-object list-box% #f (get-face-list) p refresh-sample)]
 	       [p2 (make-object vertical-pane% p)]
 	       [p3 (instantiate horizontal-pane% (p2) [stretchable-width #f])]
 	       [style (let ([pnl (instantiate group-box-panel% ("Style" p3) [stretchable-height #f] [stretchable-width #f])])
diff --git a/collects/mred/private/gdi.ss b/collects/mred/private/gdi.ss
index d7716f8e65..e254651939 100644
--- a/collects/mred/private/gdi.ss
+++ b/collects/mred/private/gdi.ss
@@ -1,6 +1,7 @@
 (module gdi mzscheme
   (require (lib "class.ss")
 	   (lib "class100.ss")
+           (lib "list.ss")
 	   (prefix wx: "kernel.ss")
 	   "lock.ss"
 	   "check.ss"
@@ -19,7 +20,8 @@
 	   small-control-font
 	   tiny-control-font
 	   view-control-font
-	   menu-control-font)
+	   menu-control-font
+           get-face-list)
 
   (define register-collecting-blit
     (case-lambda
@@ -191,6 +193,32 @@
 	(let-values ([(w h d a) (send dc get-text-extent string font)])
 	  (values (inexact->exact w) (inexact->exact h)))])))
 
+  
+  (define ugly?
+    (lambda (a)
+      (and (positive? (string-length a))
+           (not (or (char-alphabetic? (string-ref a 0))
+                    (char-numeric? (string-ref a 0))
+                    (char=? #\- (string-ref a 0)))))))
+
+  (define compare-face-names
+    (lambda (a b)
+      (let ([a-sp? (char=? #\space (string-ref a 0))]
+            [b-sp? (char=? #\space (string-ref b 0))]
+            [a-ugly? (ugly? a)]
+            [b-ugly? (ugly? b)])
+        (cond [(eq? a-sp? b-sp?)
+               (cond
+                [(eq? a-ugly? b-ugly?)
+                 (string-locale-ci<? a b)]
+                [else b-ugly?])]
+              [else a-sp?]))))
+
+  (define get-face-list
+    (case-lambda
+     [() (get-face-list 'all)]
+     [(a) (sort (wx:get-face-list a) compare-face-names)]))
+
   (define x-has-xft? 'unknown)
   (define mswin-system #f)
   (define mswin-default #f)