diff --git a/collects/mred/private/wx/cocoa/canvas.rkt b/collects/mred/private/wx/cocoa/canvas.rkt
index 58a7b31161..93bf8d54eb 100644
--- a/collects/mred/private/wx/cocoa/canvas.rkt
+++ b/collects/mred/private/wx/cocoa/canvas.rkt
@@ -223,15 +223,17 @@
           (when pq (set-box! pq #f)))
         (set! paint-queued #f)
         (when (or (not b) (is-shown-to-root?))
-          (send dc reset-backing-retained) ; start with a clean slate
           (send dc ensure-ready)
+          (send dc erase) ; start with a clean slate
           (let ([bg (get-canvas-background)])
             (when bg 
               (let ([old-bg (send dc get-background)])
                 (send dc set-background bg)
                 (send dc clear)
                 (send dc set-background old-bg))))
+          (send dc suspend-flush)
           (on-paint)
+          (send dc resume-flush)
           (queue-backing-flush)))
       (when req
         (cancel-flush-delay req)))
diff --git a/collects/mred/private/wx/cocoa/window.rkt b/collects/mred/private/wx/cocoa/window.rkt
index 5709b1dc77..39492e5b6f 100644
--- a/collects/mred/private/wx/cocoa/window.rkt
+++ b/collects/mred/private/wx/cocoa/window.rkt
@@ -449,7 +449,16 @@
       ;; Called in Cocoa event-handling mode
       #f)
 
+    (define/private (pre-event-refresh key?)
+      ;; Since we break the connection between the
+      ;; Cocoa queue and event handling, we
+      ;; re-sync the display in case a stream of
+      ;; events (e.g., key repeat) have a corresponding
+      ;; stream of screen updates.
+      (try-to-sync-refresh))
+
     (define/public (dispatch-on-char/sync e)
+      (pre-event-refresh #t)
       (dispatch-on-char e #f))
     (define/public (dispatch-on-char e just-pre?) 
       (cond
@@ -459,6 +468,7 @@
        [else (when enabled? (on-char e)) #t]))
 
     (define/public (dispatch-on-event/sync e)
+      (pre-event-refresh #f)
       (dispatch-on-event e #f))
     (define/public (dispatch-on-event e just-pre?) 
       (cond
diff --git a/collects/mred/private/wx/common/backing-dc.rkt b/collects/mred/private/wx/common/backing-dc.rkt
index b711207ebf..4c64089769 100644
--- a/collects/mred/private/wx/common/backing-dc.rkt
+++ b/collects/mred/private/wx/common/backing-dc.rkt
@@ -32,7 +32,8 @@
     (inherit call-with-cr-lock
              internal-get-bitmap
              internal-set-bitmap
-             reset-cr)
+             reset-cr
+             erase)
 
     (super-new)
 
@@ -68,7 +69,7 @@
 
     (define/public (reset-backing-retained [proc void])
       (let ([cr retained-cr])
-        (when cr
+        (when cr 
           (let ([bm (internal-get-bitmap)])
             (set! retained-cr #f)
             (internal-set-bitmap #f #t)
diff --git a/collects/mred/private/wx/gtk/canvas.rkt b/collects/mred/private/wx/gtk/canvas.rkt
index 2c209f1cd5..b8069171ab 100644
--- a/collects/mred/private/wx/gtk/canvas.rkt
+++ b/collects/mred/private/wx/gtk/canvas.rkt
@@ -349,15 +349,17 @@
          (lambda () 
            (set! paint-queued? #f)
            (set! now-drawing? #t)
-           (send dc reset-backing-retained) ; clean slate
            (send dc ensure-ready)
+           (send dc erase) ; clean slate
            (let ([bg (get-canvas-background)])
              (when bg 
                (let ([old-bg (send dc get-background)])
                  (send dc set-background bg)
                  (send dc clear)
                  (send dc set-background old-bg))))
+           (send dc suspend-flush)
            (on-paint)
+           (send dc resume-flush)
            (set! now-drawing? #f)
            (when refresh-after-drawing?
              (set! refresh-after-drawing? #f)
diff --git a/collects/racket/draw/dc.rkt b/collects/racket/draw/dc.rkt
index b6dd6431a4..70aa96c57e 100644
--- a/collects/racket/draw/dc.rkt
+++ b/collects/racket/draw/dc.rkt
@@ -139,7 +139,11 @@
     ;;
     ;; Return #t if bitmap drawing with a mask is supported.
     ;; It's not supported for PostScirpt output, for example.
-    can-mask-bitmap?))
+    can-mask-bitmap?
+
+    ;; erase : -> void
+    ;; A public method: erases all drawing
+    erase))
 
 (define default-dc-backend%
   (class* object% (dc-backend<%>)
@@ -198,6 +202,9 @@
     (define/public (can-mask-bitmap?)
       #t)
 
+    (define/public (erase)
+      (void))
+
     (super-new)))
 
 (define hilite-color (send the-color-database find-color "black"))
@@ -571,6 +578,14 @@
        (install-color cr bg 1.0)
        (cairo_paint cr)))
 
+    (define/override (erase)
+      (with-cr
+       (void)
+       cr
+       (cairo_set_operator cr CAIRO_OPERATOR_CLEAR)
+       (cairo_set_source_rgba cr 1.0 1.0 1.0 1.0)
+       (cairo_paint cr)
+       (cairo_set_operator cr CAIRO_OPERATOR_OVER)))
 
     (define/private (make-pattern-surface cr col draw)
       (let* ([s (cairo_surface_create_similar (cairo_get_target cr)
@@ -963,7 +978,7 @@
                               (not (= 1.0 effective-scale-x))
                               (not (= 1.0 effective-scale-y)))
                           (values #f #f #f #f)
-                          (let ([id (send font get-font-id)]
+                          (let ([id (send font get-font-key)]
                                 [sz (send font get-point-size)])
                             (let loop ([i offset] [w 0.0] [h 0.0] [d 0.0] [a 0.0])
                               (if (= i (string-length s))
@@ -1075,7 +1090,7 @@
                              (not (= 1.0 effective-scale-x))
                              (not (= 1.0 effective-scale-y)))
                          void
-                         (let ([id (send font get-font-id)]
+                         (let ([id (send font get-font-key)]
                                [sz (send font get-point-size)])
                            (lambda (ch w h d a)
                              (atomically
diff --git a/collects/racket/draw/font.rkt b/collects/racket/draw/font.rkt
index 1aa46d1ca4..ca187ac1c5 100644
--- a/collects/racket/draw/font.rkt
+++ b/collects/racket/draw/font.rkt
@@ -1,5 +1,6 @@
 #lang scheme/base
 (require scheme/class
+         ffi/unsafe/atomic
          "syntax.ss"
          "pango.ss"
          "font-syms.ss"
@@ -26,12 +27,19 @@
 (define (size? v) (and (exact-positive-integer? v)
                        (byte? v)))
 
-(define-local-member-name s-set-key)
+(define-local-member-name s-set-table-key)
+
+(define font-descs (make-weak-hash))
+(define ps-font-descs (make-weak-hash))
+(define keys (make-weak-hash))
+
+(define-syntax-rule (atomically e)
+  (begin (start-atomic) (begin0 e (end-atomic))))
 
 (defclass font% object%
 
-  (define key #f)
-  (define/public (s-set-key k) (set! key k))
+  (define table-key #f)
+  (define/public (s-set-table-key k) (set! table-key k))
 
   (define cached-desc #f)
   (define ps-cached-desc #f)
@@ -39,15 +47,21 @@
   (define/public (get-pango)
     (create-desc #f 
                  cached-desc
+                 font-descs
                  (lambda (d) (set! cached-desc d))))
 
   (define/public (get-ps-pango)
     (create-desc #t
                  ps-cached-desc
+                 ps-font-descs
                  (lambda (d) (set! ps-cached-desc d))))
 
-  (define/private (create-desc ps? cached-desc install!)
+  (define/private (create-desc ps? cached-desc font-descs install!)
     (or cached-desc
+        (let ([desc (atomically (hash-ref font-descs key #f))])
+          (and desc
+               (install! desc)
+               desc))
         (let* ([desc (pango_font_description_new)])
           (pango_font_description_set_family desc 
                                              (if ps?
@@ -73,6 +87,7 @@
               (pango_font_description_set_absolute_size desc (* size PANGO_SCALE))
               (pango_font_description_set_size desc (inexact->exact (floor (* size PANGO_SCALE)))))
           (install! desc)
+          (atomically (hash-set! font-descs key desc))
           desc)))
 
   (define/public (get-pango-attrs)
@@ -105,6 +120,7 @@
   (def/public (get-weight) weight)
 
   (def/public (get-font-id) id)
+  (def/public (get-font-key) key)
 
   (def/public (screen-glyph-exists? [char? c]
                                     [any? [for-label? #f]])
@@ -151,7 +167,15 @@
   (define id 
     (if face
         (send the-font-name-directory find-or-create-font-id face family)
-        (send the-font-name-directory find-family-default-font-id family))))
+        (send the-font-name-directory find-family-default-font-id family)))
+  (define key
+    (let ([key (vector id size style weight underlined? smoothing size-in-pixels?)])
+      (let ([old-key (atomically (hash-ref keys key #f))])
+        (if old-key
+            (weak-box-value old-key)
+            (begin
+              (atomically (hash-set! keys key (make-weak-box key)))
+              key))))))
 
 ;; ----------------------------------------
 
@@ -186,7 +210,7 @@
                  (ephemeron-value e))
             (let* ([f (apply make-object font% (vector->list key))]
                    [e (make-ephemeron key f)])
-              (send f s-set-key key)
+              (send f s-set-table-key key)
               (hash-set! fonts key e)
               f))))))
 
diff --git a/collects/racket/draw/local.rkt b/collects/racket/draw/local.rkt
index 8c988555b4..e2ec46966b 100644
--- a/collects/racket/draw/local.rkt
+++ b/collects/racket/draw/local.rkt
@@ -29,6 +29,7 @@
 
   ;; font%
   get-ps-pango
+  get-font-key
 
   ;; dc-backend<%>
   call-with-cr-lock