diff --git a/collects/2htdp/private/image-more.rkt b/collects/2htdp/private/image-more.rkt
index 243fa83a88..4cd621a3e8 100644
--- a/collects/2htdp/private/image-more.rkt
+++ b/collects/2htdp/private/image-more.rkt
@@ -1412,7 +1412,9 @@
          build-color/make-color
          build-color/color
          build-pen/make-pen
-         build-pen/pen)
+         build-pen/pen
+         
+         render-image)
 
 (provide/contract
  [np-atomic-bb (-> np-atomic-shape? (values real? real? real? real?))]
diff --git a/collects/2htdp/tests/test-image.rkt b/collects/2htdp/tests/test-image.rkt
index 36bc7ab2e2..ae0f11ad0e 100644
--- a/collects/2htdp/tests/test-image.rkt
+++ b/collects/2htdp/tests/test-image.rkt
@@ -36,7 +36,9 @@
                   crop?
                   normalized-shape?
                   image-snip->image
-                  to-img)
+                  to-img
+                  render-normalized
+                  render-image)
          (only-in "../private/image-more.ss" 
                   bring-between
                   swizzle)
@@ -2096,6 +2098,19 @@
 
 (define-namespace-anchor anchor)
 
+;; scale-down : image -> image
+;; scale image so that it is at most 10000 pixels in area
+(define (scale-down img)
+  (let* ([w (image-width img)]
+         [h (image-height img)]
+         [s (* w h)]
+         [max-s (sqr 100)])
+    (if (< s max-s)
+        img
+        (scale/xy (/ (sqrt max-s) w) 
+                  (/ (sqrt max-s) h)
+                  img))))
+
 (define (image-struct-count obj)
   (let ([counts (make-hash)])
     (let loop ([obj obj])
@@ -2117,7 +2132,6 @@
       (error 'test-image.ss "found differing sizes for ~s:\n  ~s\n  ~s" 
              img-sexp raw-size norm-size))))
 
-
 (time
  (redex-check
   2htdp/image
@@ -2127,6 +2141,34 @@
    (to-img (eval (term image) (namespace-anchor->namespace anchor))))
   #:attempts 1000))
 
+
+(let ()
+  (define w 200)
+  (define h 200)
+  (define bm1 (make-object bitmap% w h))
+  (define bm2 (make-object bitmap% w h))
+  (define bytes1 (make-bytes (* w h 4) 0))
+  (define bytes2 (make-bytes (* w h 4) 0))
+  (define bdc1 (make-object bitmap-dc% bm1))
+  (define bdc2 (make-object bitmap-dc% bm2))
+  
+  (define (render-and-compare img)
+    (send bdc1 clear)
+    (send bdc2 clear)
+    (parameterize ([render-normalized #f])
+      (render-image img bdc1 0 0))
+    (parameterize ([render-normalized #t])
+      (render-image img bdc2 0 0))
+    (send bdc1 get-argb-pixels 0 0 w h bytes1)
+    (send bdc2 get-argb-pixels 0 0 w h bytes2)
+    (equal? bytes1 bytes2))
+  (time
+   (redex-check
+    2htdp/image
+    image
+    (render-and-compare (scale-down (eval (term image) (namespace-anchor->namespace anchor))))
+    #:attempts 100)))
+
 (define (test-save/load img fn)
   (let ([t1 (new text%)]
         [t2 (new text%)])
@@ -2137,18 +2179,6 @@
           [s2 (send t2 find-first-snip)])
       (equal? s1 s2))))
 
-;; scale-down : image -> image
-;; scale image so that it is at most 10000 pixels in area
-(define (scale-down img)
-  (let* ([w (image-width img)]
-         [h (image-height img)]
-         [s (* w h)]
-         [max-s (sqr 100)])
-    (if (< s max-s)
-        img
-        (scale/xy (/ (sqrt max-s) w) 
-                  (/ (sqrt max-s) h)
-                  img))))
 
 #;
 (time
diff --git a/collects/mrlib/image-core.rkt b/collects/mrlib/image-core.rkt
index 6776920e31..ee1a0578cc 100644
--- a/collects/mrlib/image-core.rkt
+++ b/collects/mrlib/image-core.rkt
@@ -195,6 +195,7 @@ has been moved out).
 ;                         ;;;;                      
 
 (define skip-image-equality-fast-path (make-parameter #f))
+(define render-normalized (make-parameter #f))
 
 (define image%
   (class* snip% (equal<%> image<%>)
@@ -581,7 +582,9 @@ has been moved out).
       [(is-a? image image-snip%)
        (send dc draw-bitmap (send image get-bitmap) dx dy)]
       [else
-       (render-normalized-shape (send image get-normalized-shape) dc dx dy)
+       (if (render-normalized)
+           (render-normalized-shape (send image get-normalized-shape) dc dx dy)
+           (render-arbitrary-shape (send image get-shape) dc dx dy))
        (let ([ph (send image get-pinhole)])
          (when ph
            (let* ([px (point-x ph)]
@@ -630,24 +633,103 @@ has been moved out).
 (define (render-cn-or-simple-shape shape dc dx dy)
   (cond
     [(crop? shape)
-     (let ([points (crop-points shape)])
-       (cond
-         [(equal? points (last-cropped-points))
-          (render-normalized-shape (crop-shape shape) dc dx dy)]
-         [else
-          (let ([old-region (send dc get-clipping-region)]
-                [new-region (new region% [dc dc])]
-                [path (polygon-points->path points)])
-            (send new-region set-path path dx dy)
-            (when old-region (send new-region intersect old-region))
-            (send dc set-clipping-region new-region)
-            (parameterize ([last-cropped-points points])
-              (render-normalized-shape (crop-shape shape) dc dx dy))
-            (send dc set-clipping-region old-region))]))]
+     (render-cropped-shape (crop-points shape) (crop-shape shape) (λ (s) (render-normalized-shape s dc dx dy)) dc dx dy)]
     [else
      (render-simple-shape shape dc dx dy)]))
 
+(define (render-cropped-shape points inner-shape continue dc dx dy)
+  (cond
+    [(equal? points (last-cropped-points))
+     (continue inner-shape)]
+    [else
+     (let ([old-region (send dc get-clipping-region)]
+           [new-region (new region% [dc dc])]
+           [path (polygon-points->path points)])
+       (send new-region set-path path dx dy)
+       (when old-region (send new-region intersect old-region))
+       (send dc set-clipping-region new-region)
+       (parameterize ([last-cropped-points points])
+         (continue inner-shape))
+       (send dc set-clipping-region old-region))]))
+
 (define (render-simple-shape simple-shape dc dx dy)
+  (cond
+    [(translate? simple-shape)
+     (let ([dx (+ dx (translate-dx simple-shape))]
+           [dy (+ dy (translate-dy simple-shape))]
+           [np-atomic-shape (translate-shape simple-shape)])
+       (render-np-atomic-shape np-atomic-shape
+                               dc
+                               dx dy))]
+    [else
+     (render-poly/line-segment/curve-segment simple-shape dc dx dy)]))
+
+(define (render-arbitrary-shape shape dc dx dy)
+  (let loop ([shape shape]
+             [dx dx]
+             [dy dy]
+             [x-scale 1]
+             [y-scale 1])
+    (define (scale-point p)
+      (make-point (* x-scale (point-x p))
+                  (* y-scale (point-y p))))
+    (cond
+      [(translate? shape)
+       (loop (translate-shape shape)
+             (+ dx (* x-scale (translate-dx shape)))
+             (+ dy (* y-scale (translate-dy shape)))
+             x-scale
+             y-scale)]
+      [(scale? shape)
+       (loop (scale-shape shape)
+             dx
+             dy
+             (* x-scale (scale-x shape))
+             (* y-scale (scale-y shape)))]
+      [(overlay? shape)
+       (loop (overlay-bottom shape) dx dy x-scale y-scale)
+       (loop (overlay-top shape) dx dy x-scale y-scale)]
+      [(crop? shape)
+       (render-cropped-shape
+        (map scale-point (crop-points shape))
+        (crop-shape shape)
+        (λ (s) (loop s dx dy x-scale y-scale)) dc dx dy)]
+      [(polygon? shape)
+       (let* ([this-one 
+               (make-polygon (map scale-point (polygon-points shape))
+                             (polygon-mode shape)
+                             (scale-color (polygon-color shape) x-scale y-scale))])
+         (render-poly/line-segment/curve-segment this-one dc dx dy))]
+      [(line-segment? shape)
+       (let ([this-one 
+              (make-line-segment (scale-point (line-segment-start shape))
+                                 (scale-point (line-segment-end shape))
+                                 (scale-color (line-segment-color shape) x-scale y-scale))])
+         (render-poly/line-segment/curve-segment this-one dc dx dy))]
+      [(curve-segment? shape)
+       ;; the pull is multiplied by the distance 
+       ;; between the two points when it is drawn,
+       ;; so we don't need to scale it here
+       (let ([this-one 
+              (make-curve-segment (scale-point (curve-segment-start shape))
+                                  (curve-segment-s-angle shape)
+                                  (curve-segment-s-pull shape)
+                                  (scale-point (curve-segment-end shape))
+                                  (curve-segment-e-angle shape)
+                                  (curve-segment-e-pull shape)
+                                  (scale-color (curve-segment-color shape) x-scale y-scale))])
+         (render-poly/line-segment/curve-segment this-one dc dx dy))]
+      [(or (bitmap? shape) (np-atomic-shape? shape))
+       (let* ([shape (if (bitmap? shape) 
+                         (make-flip #f shape)
+                         shape)]
+              [this-one (scale-np-atomic x-scale y-scale shape)])
+         (render-np-atomic-shape this-one dc dx dy))]
+      [else 
+       (error 'normalize-shape "unknown shape ~s\n" shape)])))
+
+(define/contract (render-poly/line-segment/curve-segment simple-shape dc dx dy)
+  (-> (or/c polygon? line-segment? curve-segment?) any/c any/c any/c void?)
   (cond
     [(polygon? simple-shape)
      (let ([mode (polygon-mode simple-shape)]
@@ -695,54 +777,52 @@ has been moved out).
        (send dc set-pen (mode-color->pen 'outline (curve-segment-color simple-shape)))
        (send dc set-brush "black" 'transparent)
        (send dc set-smoothing 'smoothed)
-       (send dc draw-path path dx dy))]
-    [else
-     (let ([dx (+ dx (translate-dx simple-shape))]
-           [dy (+ dy (translate-dy simple-shape))]
-           [np-atomic-shape (translate-shape simple-shape)])
-       (cond
-         [(ellipse? np-atomic-shape)
-          (let* ([path (new dc-path%)]
-                 [ew (ellipse-width np-atomic-shape)]
-                 [eh (ellipse-height np-atomic-shape)]
-                 [θ (degrees->radians (ellipse-angle np-atomic-shape))]
-                 [color (ellipse-color np-atomic-shape)]
-                 [mode (ellipse-mode np-atomic-shape)])
-            (let-values ([(rotated-width rotated-height) (ellipse-rotated-size ew eh θ)])
-              (send path ellipse 0 0 ew eh)
-              (send path translate (- (/ ew 2)) (- (/ eh 2)))
-              (send path rotate θ)
-              (send dc set-pen (mode-color->pen mode color))
-              (send dc set-brush (mode-color->brush mode color))
-              (send dc set-smoothing (mode-color->smoothing mode color))
-              (send dc draw-path path dx dy)))]
-         [(flip? np-atomic-shape) 
-          (let ([bm (get-rendered-bitmap np-atomic-shape)]) 
-            (send dc draw-bitmap 
-                  bm
-                  (- dx (/ (send bm get-width) 2))
-                  (- dy (/ (send bm get-height) 2))
-                  'solid
-                  (send the-color-database find-color "black")
-                  (get-rendered-mask np-atomic-shape)))]
-         [(text? np-atomic-shape)
-          (let ([θ (degrees->radians (text-angle np-atomic-shape))]
-                [font (send dc get-font)])
-            (send dc set-font (text->font np-atomic-shape))
-            (let ([color (get-color-arg (text-color np-atomic-shape))])
-              (send dc set-text-foreground 
-                    (cond
-                      [(string? color)
-                       (or (send the-color-database find-color color)
-                           (send the-color-database find-color "black"))]
-                      [else color])))
-            (let-values ([(w h _1 _2) (send dc get-text-extent (text-string np-atomic-shape))])
-              (let ([p (- (make-rectangular dx dy)
-                          (* (make-polar 1 (- θ)) (make-rectangular (/ w 2) (/ h 2))))])
-                (send dc draw-text (text-string np-atomic-shape) 
-                      (real-part p)
-                      (imag-part p) 
-                      #f 0 θ))))]))]))
+       (send dc draw-path path dx dy))]))
+
+(define (render-np-atomic-shape np-atomic-shape dc dx dy)
+  (cond
+    [(ellipse? np-atomic-shape)
+     (let* ([path (new dc-path%)]
+            [ew (ellipse-width np-atomic-shape)]
+            [eh (ellipse-height np-atomic-shape)]
+            [θ (degrees->radians (ellipse-angle np-atomic-shape))]
+            [color (ellipse-color np-atomic-shape)]
+            [mode (ellipse-mode np-atomic-shape)])
+       (let-values ([(rotated-width rotated-height) (ellipse-rotated-size ew eh θ)])
+         (send path ellipse 0 0 ew eh)
+         (send path translate (- (/ ew 2)) (- (/ eh 2)))
+         (send path rotate θ)
+         (send dc set-pen (mode-color->pen mode color))
+         (send dc set-brush (mode-color->brush mode color))
+         (send dc set-smoothing (mode-color->smoothing mode color))
+         (send dc draw-path path dx dy)))]
+    [(flip? np-atomic-shape) 
+     (let ([bm (get-rendered-bitmap np-atomic-shape)]) 
+       (send dc draw-bitmap 
+             bm
+             (- dx (/ (send bm get-width) 2))
+             (- dy (/ (send bm get-height) 2))
+             'solid
+             (send the-color-database find-color "black")
+             (get-rendered-mask np-atomic-shape)))]
+    [(text? np-atomic-shape)
+     (let ([θ (degrees->radians (text-angle np-atomic-shape))]
+           [font (send dc get-font)])
+       (send dc set-font (text->font np-atomic-shape))
+       (let ([color (get-color-arg (text-color np-atomic-shape))])
+         (send dc set-text-foreground 
+               (cond
+                 [(string? color)
+                  (or (send the-color-database find-color color)
+                      (send the-color-database find-color "black"))]
+                 [else color])))
+       (let-values ([(w h _1 _2) (send dc get-text-extent (text-string np-atomic-shape))])
+         (let ([p (- (make-rectangular dx dy)
+                     (* (make-polar 1 (- θ)) (make-rectangular (/ w 2) (/ h 2))))])
+           (send dc draw-text (text-string np-atomic-shape) 
+                 (real-part p)
+                 (imag-part p) 
+                 #f 0 θ))))]))
 
 (define (polygon-points->path points)
   (let ([path (new dc-path%)])
@@ -1064,6 +1144,7 @@ the mask bitmap and the original bitmap are all together in a single bytes!
          save-image-as-bitmap
          
          skip-image-equality-fast-path
+         render-normalized
          
          scale-np-atomic